Night Owl 6/Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso/034a/twview82.zip/VIEWDOS.INC

Text File | 1991-02-04 | 13KB | 434 lines

procedure View;
var
  Grid      : screen;
  OnScreen  : SectorToScreen;
  XMax      : integer;
  XDim      : XIndex;
  XLength   : integer;
  YMax      : integer;
  YDim      : YIndex;
  YLength   : integer;

function xpixel( i,j : integer ) : integer;
begin
  if not odd( j ) then
    xpixel := (2 * i - 1) * XLength
  else
    xpixel := 2 * i * XLength;
end;

function ypixel( i,j : integer ) : integer;
begin
  ypixel := (2 * j - 1) * Ylength;
end;

function NumVal( n : integer ) : string;
var
  temp : string;
begin
  str( n, temp );
  NumVal := temp;
end; {NumVal}

procedure Tag( var STS : sectorToScreen;
               var scr : screen;
                   num : sector;
                  irow : XIndex;
                  jcol : YIndex );
{ put sector num into screen scr at irow, jcol; update sts accordingly }
begin
  if sts[ num].visible then
    writeln('sector ', num, ' already placed before Tag!')
  else if scr[ irow, jcol ].sectorNum <> 0 then
    writeln('row ', irow, ', col ', jcol, ' already in use!')
  else
    begin
      with STS[ num ] do
        begin
          visible := true;
          row     := irow;
          col     := jcol;
        end; {with}
      scr[ irow, jcol ].SectorNum := num;
    end; {else}
end; {tag}

procedure CheckOffspring( var P : Queue; where : sector; maxDist : integer);
{ Check all sectors from "where" to see if they should be pushed
onto the Queue }
var
  t : warpIndex;
begin
  with space.sectors[ where ] do
    if number > 0 then
      for t := 1 to number do
        if (not OnScreen[ data[ t ] ].visible) and
           (Distances[ data[t] ].d <= maxDist)    then
          enqueue( P, where, data[ t ] );
end; {check offspring}

procedure GoDirection( d : integer;
                   var Row   : XIndex;
                   var Col   : YIndex);
{ 0 is upleft, 1 left, 2 downleft, 3 downright, etc mod 6 }
begin
  d := abs( d ) mod 6;
  if odd( Col ) then
    case d of
      0 : begin
            if Col > 1 then col := col - 1;
            if Row < XDim then row := row + 1;
          end;
      1 : if Row < XDim then row := row + 1;
      2 : begin
            if Col < YDim then col := col + 1;
            if Row < XDim then row := row + 1;
          end;
      3 : if Col < YDim then col := col + 1;
      4 : if row > 1 then row := row - 1;
      5 : if Col > 1 then col := col - 1;
    end {case}
  else
    case d of
    0 : if Col > 1 then col := col - 1;
    1 : if Row < XDim then row := row + 1;
    2 : if Col < YDim then col := col + 1;
    3 : begin
          if Col < YDim then col := col + 1;
          if Row > 1 then row := row - 1;
        end;
    4 : if Row > 1 then row := row - 1;
    5 : begin
          if Col > 1 then col := col - 1;
          if Row > 1 then row := row - 1;
        end;
    end; {case}
end;

procedure seek( var freerow : Xindex; var freecol : Yindex; home : sector );
const
  MaxTries = 100;
var
  one, two, three, n : integer;
{ Trying to find a home for the new guy, close to the home sector.
one, two, and three will be random directions to try (of radius 1, 2, and
3).  When we are successful, we just break out of the procedure, hopefully
returning a freerow and freecol. }
begin
  one := random( 6 );
  for one := one to one + 5 do { from random start, advance 5 positions }
    begin
      freerow := OnScreen[ home ].row;
      freecol := OnScreen[ home ].col;
      GoDirection( one, freerow, freecol );
      if grid[ freerow, freecol ].SectorNum = 0 then
        exit;
    end; {one}
  one := random( 6 );
  two := random( 6 );
  for one := one to one + 5 do
    for two := two to two + 5 do
      begin
        freerow := OnScreen[ home ].row;
        freecol := OnScreen[ home ].col;
        GoDirection( one, freerow, freecol );
        GoDirection( two, freerow, freecol );
        if grid[ freerow, freecol ].SectorNum = 0 then
          exit;
      end; {one two}
  one := random( 6 );
  two := random( 6 );
  three := random( 6 );
  for one := one to one + 5 do
    for two := two to two + 5 do
      for three := three to three + 5 do
        begin
          freerow := OnScreen[ home ].row;
          freecol := OnScreen[ home ].col;
          GoDirection( one, freerow, freecol );
          GoDirection( two, freerow, freecol );
          GoDirection( three, freerow, freecol );
          if grid[ freerow, freecol ].SectorNum = 0 then
            exit;
        end; {one two three}
  writeln('couldn''t place anything near ', home );
  n := 0;
  repeat
    freerow := random( xdim ) + 1;
    freecol := random( ydim ) + 1;
    n := n + 1;
  until (n = MaxTries) or (grid[ freerow, freecol ].sectorNum = 0);
end; {seek}

procedure FindHome( var Grid : screen;
                    var Showing : SectorToScreen;
                        home, near : sector );
{ This is an interesting bit: given the home sector, find an open slot
in the Grid to place the near sector. }
var
  basedir : integer;
  baserow : XIndex;
  basecol : YIndex;
begin
{  writeln('Trying to find a home for ', near, ' close to ', home );
  writeln('starting at ', showing[ home ].row, showing[ home ].col ); }
  seek( baserow, basecol, home );
  if grid[ baserow, basecol ].SectorNum <> 0 then
    writeln('Seek Failed!')
  else
    Tag( Showing, Grid, near, baserow, basecol );
{  writeln('chose ', baserow, ' ', basecol );
  readln; }
end;

procedure PlaceSectors( var Grid  : screen;
                        var Showing : SectorToScreen;
                        var maxDist : integer;
                        var BaseSect : sector );
var
  PlaceMe : Queue;
  daddy, sonny : sector;
begin
  Tag( showing, Grid, baseSect, XDim div 2, YDim div 2 ); { put first in center}
  PlaceMe.front := 0;
  CheckOffspring( PlaceMe, baseSect, maxdist );
  While PlaceMe.front <> 0 do
    begin
      serve( PlaceMe, daddy, sonny );
      if not showing[ sonny ].visible then
        begin
          FindHome( Grid, Showing, daddy, sonny );
          if Showing[ sonny ].visible then             { if he didn't make it}
            CheckOffspring( PlaceMe, sonny, maxDist ); { don't look for kids }
        end;{if not showing}
    end; {while}
end; {while}

procedure InitSectorToScreen( var s : SectorToScreen );
var
  n : sector;
begin
  for n := 1 to 1000 do
    s[ n ].visible := false;
end;

procedure InitScreen( var s : Screen );
var
  r : XIndex;
  c : YIndex;
begin
  for r := 1 to XDim do for c := 1 to YDim do
    s[ r, c ].sectorNum := 0;
end;

procedure FillGrid( var Grid : screen;
                    var Showing : SectorToScreen;
                    var Distances : distanceArray );
{ Choose a sector, and fill Distances with distance to that sector,
as well as Showing and Grid based on nearby vertices. }
var
  maxD : integer;
  sn   : sector;
  ch   : char;
begin
  repeat
    write('Starting at which sector? ');
    readln( sn );
    if space.sectors[ sn ].number = 0 then
      writeln('You have never visited ', sn );
  until space.sectors[ sn ].number > 0;
  FixDistances( sn, Distances );
  repeat
    write( 'Max distance to include? ');
    readln( maxD );
    writeln( 'Total of ', CountDist( maxD), ' at distance at most ', MaxD );
    write('Is this okay?  (y/n) ');
    readln( ch );
  until ch in ['Y','y'];
  InitSectorToScreen( Showing );
  InitScreen( Grid );
  PlaceSectors( Grid, Showing, maxD, sn );
end; {FillGrid}

function PortColor( g : stuff ) : word;
begin
  if GetMaxColor = 1 then
    PortColor := 0
  else
    case g of
      -1 : PortColor := 0;
       0 : PortColor := 1;
       1 : PortColor := 2;
       2 : PortColor := 3;
       3 : PortColor := 4;
       4 : PortColor := 5;
       5 : PortColor := 9;
       6 : PortColor :=10;
       7 : PortColor :=11;
       8 : PortColor :=12;
    end; {case}
end; {PortColor}

function  SectorColor( s : sector ) : word;
begin
  if GetMaxColor = 1 then {monochrome}
    SectorColor := 1
  else  {not monochrome }
    if space.sectors[ s ].number > 0 then
      if space.sectors[ s ].porttype <> NotAPort then
        SectorColor := GetMaxColor
      else
        SectorColor := 7
    else
      SectorColor := 14;
end; {SectorColor}

procedure CircleSector( x : XIndex; y : YIndex; s : sector );
var
  r, c, xradius : integer;
  ColorUsed,
  xasp, yasp    : word;
begin
  r := xpixel( x, y );
  c := ypixel( x, y );
  GetAspectRatio( xasp, yasp );
  xradius := round( yasp/xasp * ylength/2);
  SetFillStyle( 0, 0);
  SetLineStyle( SolidLn, 0, NormWidth );
  if space.sectors[ s ].number > 0 then
    SetColor( GetMaxColor )
  else
    SetColor( 0 );
  FillEllipse( r, c, xradius, ylength div 2);
  SetColor( SectorColor( s ) );
  with space.sectors[ s ] do
    if number <> Unexplored then
      if porttype <> NotAPort then
        begin
          ColorUsed := PortColor( space.sectors[ s ].porttype );
          SetFillStyle( 1, ColorUsed );
          bar( r - xradius, c - ylength div 2, r + xradius,
               c + ylength div 2 );
          rectangle( r - xradius, c - ylength div 2,
               r + xradius, c + ylength div 2 );
          if ColorUsed > 9 then
            SetColor( 0 );
        end {if if}
      else
        circle( r, c, xradius );
    outTextXY( r, c, NumVal( s ) );
end;

procedure ConnectVertices( i1, i2 : XIndex; j1, j2 : YIndex;
                           TwoWay : boolean );
var
  x1, y1, x2, y2 : integer;
begin
  x1 := xpixel( i1, j1 );
  y1 := ypixel( i1, j1 );
  x2 := xpixel( i2, j2 );
  y2 := ypixel( i2, j2 );
  if TwoWay then
    SetLineStyle( SolidLn, 0, NormWidth )
  else
    SetLineStyle( DashedLn, 0, ThickWidth );
  MoveTo( x1, y1 );
  LineTo( x2, y2 );
end;

procedure DrawGrid( var G : screen; STS : SectorToScreen );
var
  i : XIndex;
  j : YIndex;
  t : WarpIndex;
  temp : integer;
begin
  for i := 1 to XDim do
    for j := 1 to YDim do
      if G[ i, j ].sectorNum <> 0 then
        with G[ i, j ] do
          with space.sectors[ sectorNum ] do if number > 0 then
            for t := 1 to number do
              if STS[ data[ t ] ].visible then
                ConnectVertices( i, STS[data[t] ].row, j, STS[data[t]].col,
                                 IsWarp( data[t], sectorNum ) );
  for i := 1 to XDim do
    for j := 1 to YDim do
      if G[ i, j ].sectorNum <> 0 then
          CircleSector( i, j, G[i,j].sectorNum );
end;

{$I initgrph.inc }

procedure GetDimensions( var x : XIndex; var xl : integer;
                         var y : YIndex; var yl : integer );
const
  whitespace : set of char = [' ', #9, #10, #13 ];
var
  line : string;
  ok   : boolean;
  tempx, tempy,
  position : integer;
begin
  ok := false;
  repeat
    write('Max dimensions? [', XDimMax, ' by ', YDimMax, ']  ');
    readln( line );
    if line = '' then
      begin
        ok := true;
        x := XDimMax * 2 div 3;
        y := YDimMax * 2 div 3;
      end
    else
      begin
        position := 1;
        tempx := 0;
        while (position <= length( line )) and
              (line[position] in ['0'..'9']) do
          begin
            tempx := 10 * tempx + ord( line[ position ] ) - ord( '0' );
            inc( position );
          end; {while}
        inc( position );
        while (position <= length( line ) ) and
              (line[position] in whitespace) do
          inc( position );
        tempy := 0;
        while (position <= length( line )) and
              (line[position] in ['0'..'9']) do
          begin
            tempy := 10 * tempy + ord( line[position] ) - ord('0');
            inc( position );
          end; {while}
        ok := (tempx>0) and (tempx<=XDimMax) and (tempy>0) and (tempy<=YDimMax);
        if ok then
          begin
            x := tempx;
            y := tempy;
          end {if}
        else
          begin
            writeln('I don''t understand ', line );
            writeln('Please give two integers separated by a space.');
          end; {else}
      end; {else}
  until ok;
  InitGraphics;
  XMax := GetMaxX;
  YMax := GetMaxY;
  closeGraph;
  xl := trunc( XMax / x / 2 );
  yl := trunc( YMax / y / 2);
end;

begin {view}
    GetDimensions( XDim, XLength, YDim, Ylength );
    FillGrid( Grid, OnScreen, Distances );
    InitGraphics;
    DrawGrid( Grid, Onscreen );
    readln;
    closeGraph;
end; {view}